COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	C ***** SCANNER *************************  
C00023 ENDMK
C⊗;
C ***** SCANNER *************************  
C* SCANR,BGSORT,FMT,RANR,SQYY,COLTTY,READER,CLEAN,ACCEL,POINTR  7/74
	SUBROUTINE SCANR
	DIMENSION IP(30)
	COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
	1/E/IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
	1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
	EQUIVALENCE(IF,ISCA(6)),(ISS,ISCA(9)),(IE,ISCA(5)),(IDOT,IDAT(11))
	1 ,(IEN,ISCA(4)),(IP,PL)
C 2/74 IP IS NOW EQUIV TO PL!  USED TO BE IP WITH P.(HURT 'TAP' ROUTINE.)
C  WILL THIS DO ANYTHING TO MUSIC5 VERSION??
      NNUM=-1     
      ISKP=0
      JJ=0  
	XMINUS=1.    
999      IDECI=-1  
      M=0   
2799	N=INP(ML)
	IF(N.NE.IQT)GO TO 899
	JA=-1
	ML=ML+1
	ISUB=8
	JJ=JJ+1
	VX(JJ)=ML
C  POINTS TO FIRST LIT. CHAR.
	DO 1177 K=ML,144
	IF(INP(K).NE.IQT)GO TO 1177
	ML=K+1
2177	N=INP(ML)
	GO TO 899
1177	CONTINUE
C  SKIPS 'LIT' ITEMS IN RAN. SELECTION
899   ML=ML+1
	IF(N.EQ.':')GO TO 751
	IF(N.EQ.ISEMI)GO TO 751
	IF(N.NE.IBLA)GO TO 510
4702      IF(ISKP)202,2799,2799

510	IF(JA)GO TO 70
C********** MAY 22,71
      DO 77 K=1,12   
      IF(N.NE.ISCA(K))GO TO 77
	IF(K.EQ.2)GO TO 1511
	IF(K.NE.4)GO TO 511
1511	NSWCH=K-4
	GO TO 2177
C  TO SWITCH ALWAYS USE OCT.#  /PBF4/  /OE5/  P=PROXIMITY, O=ORDINARY
C ************ MAY 22,71
511   NNUM=K
	JJ=JJ+1
	NFLG=-1
	N=INP(ML)
	IF(N.NE.IF)GO TO 410
	NNUM=NNUM-1
	GO TO 610
410	IF(N.NE.ISS)GO TO 3410
	NNUM=NNUM+1
610	ML=ML+1
	N=INP(ML)
3410	IF(N.EQ.IEN)GO TO 3411
	IF(N.NE.'I')GO TO 371
C  'END' OR 'FINE' WILL END INST.
C******** MAY 20,71
3411	VX(JJ)=-10000.
CIRC3411	VX(JJ)=10000.
	IF(DUR(LK))DUR(LK)=1000.
	IAMP=-1
	RETURN
371	IF(N.EQ.ISEMI)GO TO 5410
	IF(N.EQ.IBLA)GO TO 5410
	DO 177 KN=2,9
	IF(N.NE.IDAT(KN))GO TO 177
	IF(KN.EQ.9)CALL ERR(4)
C FOUND OCTAVE NUM.8 -- TOO HIGH!
	JSCA=KN-2
	ML=ML+1
	GO TO 2410
177	CONTINUE
	GO TO 6410
5410	KN=-1
6410	IF(NSWCH.EQ.0)GO TO 2410
	IF(KN)GO TO 7410
CC	IF(N.EQ.'+')NOLD=NOLD+6
CC	IF(N.EQ.'-')NOLD=NOLD-6
C /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
7410	IF(NOLD-NNUM.LE.5)GO TO 7411
	IF(JSCA.LT.7)JSCA=JSCA+1
7411	IF(NOLD-NNUM.GE.-5)GO TO 2410
	IF(JSCA.GT.0)JSCA=JSCA-1
C   WILL JUMP TO NEAREST NOTE ***********  MAY 22,71
2410	VX(JJ)=JSCA*12+NNUM
	NOLD=NNUM
C ********** MAY 22,71
4410	NNUM=-2
	IF(INP(ML).EQ.ISEMI)RETURN
C   ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
	IF(N.EQ.IXX)GO TO 210
	IF(N.EQ.'*')GO TO 210
	GO TO 310
C *********MAY 22,71
77    CONTINUE    
70    IF(N.NE.'-')GO TO 71   
      XMINUS=-1.   
      GO TO 2799   
210	JJ=JJ+1
	IF(JJ.EQ.1)GO TO 3310
C****** MAY 19,71
	XMINUS=1.
	VX(JJ)=0
C  'X N1,N2' MAY REPLACE 'REP N1,N2'.  N2=0 BECOMES N2=2
	GO TO 310
71	IF(N.EQ.IXX)GO TO 210
	IF(N.EQ.'*')GO TO 210
	IF(N.EQ.'R')GO TO 73     

1410  DO 78 K=1,11
      IF(N.NE.IDAT(K))GO TO 78
	ISKP=-1
	IF(N.NE.IDOT)GO TO 79
	IDECI=M
	GO TO 75
79    M=M+1 
      IP(M)=K-1   
	GO TO 75
78	CONTINUE
	IF(N.NE.IE)GO TO 8811
	IF(INP(ML).NE.IEN)GO TO 781
	GO TO 7811
8811	IF(N.NE.IF)GO TO 781
	IF(INP(ML).NE.'I')GO TO 781
C  'EN(D)' OR 'FI(NE)' WILL END INST.
7811	JJ=1
	GO TO 3411
781	IF(N.EQ.'/')N=ISEMI
C   FOR MOTIVIC TRANFORMATIONS

75	KN=INP(ML)
CXX	IF(KN.NE.'R')GO TO 275
CXX	IF(INP(ML+1).NE.IE)GO TO 175
C  NOW FOUND A 'REP'
CXX	ML=ML+2
CXX	GO TO 202
275	IF(KN.NE.IXX)GO TO 175
CC	IF(INP(ML+1).NE.'(')GO TO 202
C  "X(" STARTS A 'MOTIF' BUT "X (" WON'T WORK!!!!
	IF(M.NE.0)GO TO 202
175	IF(KN.EQ.'*')GO TO 202
C  FOR 2X3, 2*3, ETC.    CHECK THIS OUT.  6/74
CC75	IF(INP(ML).NE.IXX)GO TO 752
CC	ML=ML-1
CC	GO TO 202
C  FOR 'X' AND '*' WITHOUT SPACES.
	IF(N.EQ.ISEMI)GO TO 751
	IF(KN.NE.1)GO TO 2799
C WHEN IS INP(ML) (I.E. KN) SET TO 1?????
751	IF(ISKP.EQ.0)RETURN
202   IF(IDECI.NE.-1)GO TO 302    
      IDECI=0     
      GO TO 402   
302   IDECI=M-IDECI     
402   KN=0  
      IEXP=M-1    
      IF(M.LT.1)M=1     
      DO 171 K=1,M
	KV=10**IEXP
	IF(IEXP.EQ.0)KV=1
      KN=KN+IP(K)*KV 
171     IEXP=IEXP-1     
      A=10**IDECI 
	IF(IDECI.EQ.0)A=1.
	JJ=JJ+1
	VX(JJ)=KN/A*XMINUS
	IF(ISUB.EQ.1)RETURN
	IF(CODE.NE.-22.)XMINUS=1.
C  ONLY ONE - NEEDED FOR RHY.COMPOSITE
1310	IF(INP(ML).NE.1)GO TO 310
	VX(JJ+1)=VX(JJ)*2.
	JJ=JJ+1
	ML=ML+1
	GO TO 1310
206	ML=ML+2
3310	VX(1)=-99.
C******** MAY 19,71
310      ISKP=0
        IF(N.NE.ISEMI)GO TO 999

    	RETURN
73	JJ=JJ+1
	 IF(INP(ML).EQ.IE)GO TO 206    
C   NEXT IS FOR A REST ('R')  
      VX(JJ)=85.
C 7/75	GO TO 4410
731	N=INP(ML)
	IF(N.EQ.'/')RETURN
	IF(N.EQ.ISEMI)RETURN
	IF(N.NE.IBLA)GO TO 899
	ML=ML+1
	GO TO 731
  	END

	SUBROUTINE BGSORT(BW)
C  THIS SORTS BG TIMES SO NONE ARE DUPLICATED IN BNW ARRAY.
C  ALLOWS 100 BG TIMES.
	COMMON /Q/ BNW(100),NWZ
	DO 5308 K=1,NWZ
	X=BNW(K)-.0001
	Y=X+.0002
C   ROUND-OFF NONSENSE
	IF(BW.LE.X)GO TO 5308
 	IF(BW.LT.Y)RETURN
5308	CONTINUE
	NWZ=NWZ+1
	BNW(NWZ)=BW
	RETURN
	END

	SUBROUTINE FMT(JFM,INP,MLX)
	DIMENSION JFM(3),INP(1)
	DO 1 MLX=2,72
	J=INP(MLX)
	IF(J.EQ.' ')GO TO 2
	IF(J.EQ.',')GO TO 2
	IF(J.EQ.';')GO TO 2
1	CONTINUE  
C*** TEMPORARY CHANGE ***** IF(J.EQ.':')GO TO 3
C  SPACE=COMMA=SPACE, ALSO STOPS ON ";"
3	CALL ERR(1)
C  ERROR IF COLON IS FOUND OR THERE IS NO END MARK 
2	MLX=MLX+1
	IF(MLX.GT.7)MLX=7
	JFM(2)='0'+(MLX-2)*536870912
C   FINDS NUMBER FOR 'A' FORMAT
	END

      SUBROUTINE RANR(VX,K)
C   FOR RAN. SELEC. OF NOTES.  FINDS HIGHEST NOTE.
      DIMENSION VX(1)
      X=VX(K)
      Y=VX(K+1)
      IF(X.GT.Y)VX(K)=X+.999
      IF(Y.GE.X)VX(K+1)=Y+.999
      RETURN
      END

      SUBROUTINE SQYY(YY,X,Y,Z)
      YY=2.*Z/(X+Y)
      IF(YY.NE.0)YY=2.*(Z-X*YY)/YY**2
      RETURN
      END

	SUBROUTINE COLTTY(JNP,JT)
	COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED /FRMT/J(2)
	DIMENSION JNP(1)
	DATA J(2)/'72A1)'/
	DO 1 K=72,1,-1
1	IF(JNP(K).NE.' ')GO TO 2
	K=1
2	IF(JT.EQ.21)GO TO 3
	J(1)='  (1X'
	IF(LN.EQ.0)GO TO 5
	J(1)='(I6,X'
	WRITE(JT,J)LN,(JNP(L),L=1,K)
	RETURN
3	J(1)='    ('
5	WRITE(JT,J)(JNP(L),L=1,K)
	END

	FUNCTION READER(JNP)
	DIMENSION JNP(72)
	COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED
	1 /FRMT/J(2)  /IFI/IFI
	DATA TPALN/20H(' TYPE A LINE'/)   /
	J(1)='    ('
	READER=0
	IF(ITYP)GO TO 1
6 	TYPE TPALN
	ACCEPT J,JNP
	IF(JED)CALL COLTTY(JNP,21)
	IF(JNP(1).EQ.' ')GO TO 6
	RETURN
1	IF(IFI)GO TO 5
CIRC1	IF(LN.NE.0)GO TO 5
	READ(23,J,END=3)JNP
	GO TO 7
5	J(1)='  (I,'
	READ(23,J,END=3)LN,JNP
7	IF(SOS)CALL COLTTY(JNP,JOUT)
	RETURN
3	READER=-1
	END

	SUBROUTINE QUAD
C  DUMMY -- FOR NOW.  7/74
	END

	FUNCTION RMOVX(W,Y,Z)
	IF(W.EQ.0)W=.01
	IF(Y.EQ.0)Y=.01
	RMOVX=Y*((W/Y)**Z)
	END

	SUBROUTINE CLEAN(INP,LEND)
	DIMENSION INP(1)
C  CLEAR THE END OF ARRAY
	M=72
	LEND=-1
	K=0
1	K=K+1
	NN=INP(K)
	IF(NN.EQ.';')GO TO 2
	IF(NN.EQ.'/')GO TO 2
	IF(NN.EQ.'<')GO TO 3
C  USE < FOR COMMENT--  AS IN MUS10
	IF(NN.EQ.',')INP(K)=' '
C  CHANGE ALL COMMAS TO BLANKS
C**** FOR CHORD FEATURE 	IF(NN.EQ.':')CALL ERR(1)
	IF(NN.NE.'"')GO TO 4
7	K=K+1
	IF(INP(K).EQ.'"')GO TO 4
	IF(K.LT.M)GO TO 7
	CALL ERR(5)
2	LEND=K
4	IF(K.LT.M)GO TO 1
3	IF(LEND.GT.0)RETURN
	IF(M.EQ.144)CALL ERR(2)
	CALL READER(INP(73))
C  GO READ ANOTHER LINE.
	M=144
	K=72
	GO TO 1
	END

	SUBROUTINE ERR(K)
	GO TO(1,2,3,4,5)K
	TYPE 199,K
199	FORMAT(' ERROR!!  LAST LINE READ =',I6)
	CALL EXIT
1	TYPE 11
	CALL EXIT
11	FORMAT(' ILLEGAL COLON')
2	TYPE 12 
	CALL EXIT
12	FORMAT(' NO END MARK')
3	TYPE 13
	CALL EXIT
13	FORMAT(' MORE THAN 2 PARENS OPEN')
4	TYPE 14
	CALL EXIT
14	FORMAT(' SOME NUMBER OUT OF BOUNDS')
CIRC14	FORMAT(' SOME NUMBER TOO BIG')
5	TYPE 15
	CALL EXIT
15	FORMAT(' OPEN QUOTES')
	END

	SUBROUTINE ACCEL
	COMMON/VV/LIMIT,V(1)/A/ROFF(27),NP(27),PCH(27,32),
	1 RDEV(27),IPT(27,31),XT(27),OTH(20,16),SCAL(101)
	1 ,P1(27),JFM(4),COPY(30),IFM(80)
	1 ,FINM(6),TINST(5),ENFI(5),TEDIT(4),INVIS(27)
	COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
	1/E/IQ(27),KL,X,ZPAR,KA,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
	1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
	COMMON/B/MOT,PR,T5,NINS,I,TP,RA,KZY,NWX,INONLY,MX,
	1 Y,Z,ISLAC,MZ,N,IDALL,JC,JG,RB,IJ,IX,BW,KB,NL,RC,W,
	1 ZZ,CHN,YY 
	1 /C/LPAR,IPRN,QX,RETRO,INVRT,ICON,LCNT,
	1 PARENS,JZ,BY,MLX,IZ,ALL,JD,LEND,QTS,ITMP,
	1 LP,ILIT,NLIT,KTMP,IC,NONO,RD,IA
C  /C/=26
      IF(T5.EQ.1)GO TO 4020
	XA=RA
7020  RA=V(IA+K)
      IF(RA.EQ.-10000.)RETURN
4020  RD=1  
      IF(RA.LT.0)RD=-1. 
      RA=RA*RD    
      IF(KA.EQ.0)RA=RA-RC     
      W=RA  
      RB=W  
      IF(W.LE.Z-.0001)GO TO 2020    
C .0001 FOR ROUND-OFF ERRORS!!!!!!!
      IF(Z.NE.0)GO TO 3020    
      RA=RA/Y     
      RB=-1.
      RC=0  
      GO TO 8020  
3020      W=Z     
      RC=W+RC     
      GO TO 24    
2020      RC=0    
24	IF(X.NE.Y)GO TO 424
	RA=W/X
	GO TO 8020
C   DUR OF TMP + BG TIME OF TMP - NOTE VALUE - 
C   BG TIME OF NOTE. CHN=TBG.
424	RAX=XT(J)
	RA=(-2.*RAX+(4.*RAX**2+8.*YY*W)**.5)/(2.*YY)
	XT(J)=RAX+YY*RA
8020      IF(KA.EQ.0)RA=RA+XA 
      KA=1  
CXX   IF(RC.NE.0)GO TO 1011   
CCXX  IF(T5.EQ.1)RETURN
	IF(T5.NE.1)GO TO 1012
	IF(RC.NE.0)GO TO 2011
	RETURN
C  T5=1 IN 'RUNIT'
1012  V(IA+K)=RA*RD     
      IF(K.EQ.IZ)RETURN     
C*********** JUNE 1,71
1011      IF(T5.EQ.1)GO TO 2011     
      K=K+1 
      IF(ZZ.NE.0)Z=Z-W  
      IF(Z.GT.0)GO TO 7020
	IF(RB.EQ.-1.)GO TO 7020     
      IC=IC+1     
      IF(RB.EQ.W)RETURN
      KA=0  
      K=K-1 
      RETURN
2011      XA=RA   
	IF(K.GT.1)GO TO 9020
	K=I-6
      ZPAR=-9900.-CHN-ZZ
      DO 3011 KL=8,I     
      IF(V(K).NE.ZPAR)GO TO 3011
	IF(V(K+1).EQ.990000.)GO TO 9020    
3011      K=K-1
9020      W=ZZ  
	IF(V(K+3))K=K+3
C   ABOVE IS FOR TYPED IN TEMPO CHANGES
	KA=K+3
      ZZ=V(KA)
C   DUR OF NEXT TEMPI
	X=V(KA+1)
	Y=V(KA+2)
213      KA=0  
      Z=ZZ  
	CALL SQYY(YY,X,Y,Z)
      CHN=CHN+W   
	XT(J)=X
      IF(KA.EQ.1)Z=0    
      RA=PR 
	KA=0
	K=K+3
	GO TO 4020
	END

	SUBROUTINE POINTR(INUM,IPAR,ISTRT,KODE)
	COMMON/VV/LIMIT, V(2000)
C  TO FIND POINTERS TO LISTS, ETC. IN V ARRAY WHEN USING SUBR.
C KODES:  -22=RHY  -33=NOTES  -44=NUMS  -46=RLIST  -36=RNOTES
C   -11=SUBN  -12=SUBR  -55=MOVE NUMS  -56=MOVE NOTES
C  -66=DUPL   -88=LIT  -57=MOVE RANGE NUMS  -58=MOVE RNG NOTES
	DO 1 K=1,2000
	N=V(K)
	IF(N.LT.10000)GO TO 1
	IF(N/10000.NE.INUM)GO TO 1
	IF(MOD(N,10000).NE.IPAR)GO TO 1
	ISTRT=K+4
	KODE=V(K+2)
	ICNT=V(K+3)
	IF(IABS(KODE).LT.11)ISTRT=ISTRT-1
	RETURN
C  FINDS FIRST OCCURRENCE OF PARAM AND INST ONLY.
1	CONTINUE
	END

CC	SUBROUTINE NMCHG
CC	DIMENSION RNAME(5),JNM(5)
CC	COMMON /INS/ INST(27),BG(60)
CC	COMMON P(30),INUM,IPAR,CNT(27),BT,PL(48),IREST,DF,DUR(27)
CC	COMMON/VV/LIMIT, V(1) /C/T,NWZZ,IT3,T6,NW,TDUR,A,T2,T4,IL
CC	1,KODE,NPAR,LP,TBG,AC,NPA,BX,IDF,PM,NM,PAR,PX2,T1,RD,VIJ2
CC	EQUIVALENCE (RNAME,JNM)
CC	DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
CC	DATA MM/"774000000000/

CC	P(IPAR)=0
C REPLACE NAME BY A ZERO FOR THIS PARAM.
CC	PL(IPAR)=1.
CC	J=PM-1
C PM POINTS TO 1ST WORD OF LIT. STRING., PAR= LAST
CC	N=V(J)
C  THE WORD COUNT
CC	DO 15 K=1,5
CC	J=J+1
CC	X=V(J)
CC	IF(K.GT.N)X=' '
CC15	RNAME(K)=X
C N=WDCNT OF INST NAME
CC	NN=0
CC	DO 10 K=5,1,-1
CC	NN=NN .OR. (JNM(K) .AND. MM)
CC	IF (K-1) 20,20,17
CC17	IF (NN.GE.0)GO TO 13
CC	NN = (( NN .AND. LL)/KK) .OR. JJ
CC	GO TO 10
CC13	NN = NN / KK
CC10	CONTINUE
CC20	INST(INUM)=NN
CC	END
 
	SUBROUTINE SHORT(KNP,K)
C  DON'T TYPE TRAILING BLANKS
	DIMENSION KNP(1)
	DO 1 K=72,1,-1
1	IF(KNP(K).NE.' ')RETURN
	K=1
	END

C THIS ROUTINE ALLOWS NAMES OF FROM 1 TO 5 LETTERS TO BE USED.
C NO EXTENSIONS CAN BE USED.  INF RETURNS INFO REL LINE NUMS.

CC	SUBROUTINE IFILE(I,N,INF)
CC	EQUIVALENCE (NN,NAME),(NN2,NN(2))
CC	COMMON /NN/NN(2)
CC	DOUBLE PRECISION NAME
CC	DATA NN(2)/'.'/
CC5	INF=0
CC	NN(1)=N
CC	OPEN(UNIT=I,FILE=NAME)
CC	IF(NN2.NE.'.')GO TO 1
C JUMP IF COMING FROM OFILE CALL
CC	READ(I,2)K,J
CC	IF(K.NE.'00')GO TO 3
CC	INF=-1
C INF = -1  = LINE NUMBERS.
CC6	OPEN(UNIT=I,FILE=NAME)
C REOPEN IF LINE NUMS OR NO "COMMENT"
CC	GO TO 1
CC3	IF(K.NE.'CO')GO TO 6
CC	IF(J.NE.'MMENT')GO TO 6
CC4	READ(I,2)K,J
C READS COMMENTS ON DIRECTORY PAGE.
CC	IF(J.NE.';')GO TO 4
CC2	FORMAT(A2,A5)
CC1	NN2='.'
CC	END
CC	SUBROUTINE OFILE(I,N,IEXT)
CC	COMMON /NN/NN1,NN2
CC	NN2=IEXT
CC	CALL IFILE(I,N,INF)
CC	END